home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / efs / efs-netrc.el.z / efs-netrc.el
Encoding:
Text File  |  1998-05-21  |  13.7 KB  |  394 lines
  1. ;; -*-Emacs-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;
  4. ;; File:         efs-netrc.el
  5. ;; Release:      $efs release: 1.15 $
  6. ;; Version:      #Revision: 1.2 $
  7. ;; RCS:          
  8. ;; Description:  Parses ~/.netrc file, and does completion in /.
  9. ;; Author:       Sandy Rutherford <sandy@ibm550.sissa.it>
  10. ;; Created:      Fri Jan 28 19:32:47 1994 by sandy on ibm550
  11. ;; Language:     Emacs-Lisp
  12. ;;
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14.  
  15. ;;; This file is part of efs. See efs.el for copyright
  16. ;;; (it's copylefted) and warrranty (there isn't one) information.
  17.  
  18. ;;;; ------------------------------------------------------------
  19. ;;;; Provisions and requirements.
  20. ;;;; ------------------------------------------------------------
  21.  
  22. (provide 'efs-netrc)
  23. (require 'efs-cu)
  24. (require 'efs-ovwrt)
  25. (require 'passwd)
  26. (require 'efs-fnh)
  27.  
  28. ;;;; ------------------------------------------------------------
  29. ;;;; Internal Variables
  30. ;;;; ------------------------------------------------------------
  31.  
  32. (defconst efs-netrc-version
  33.   (concat (substring "$efs release: 1.15 $" 14 -2)
  34.       "/"
  35.       (substring "#Revision: 1.2 $" 11 -2)))
  36.  
  37. ;; Make the byte compiler happy.
  38. (defvar dired-directory)
  39.  
  40. ;;;; ------------------------------------------------------------
  41. ;;;; Use configuration variables.
  42. ;;;; ------------------------------------------------------------
  43.  
  44. (defvar efs-netrc-filename "~/.netrc"
  45.   "*File in .netrc format to search for passwords.
  46. If you encrypt this file, name it something other than ~/.netrc. Otherwise,
  47. ordinary FTP will bomb.
  48.  
  49. If you have any cryption package running off of find-file-hooks
  50. (such as crypt.el or crypt++.el), efs will use it to decrypt this file.
  51. Encrypting this file is a good idea!")
  52.  
  53. (defvar efs-disable-netrc-security-check nil
  54.   "*If non-nil avoid checking permissions for `efs-netrc-filename'.")
  55.  
  56. ;;;; ------------------------------------------------------------
  57. ;;;; Host / User / Account mapping support.
  58. ;;;; ------------------------------------------------------------
  59.  
  60. ;;;###autoload
  61. (defun efs-set-passwd (host user passwd)
  62.   "For a given HOST and USER, set or change the associated PASSWORD."
  63.   (interactive (list (read-string "Host: ")
  64.              (read-string "User: ")
  65.              (read-passwd "Password: ")))
  66.   (efs-set-host-user-property host user 'passwd
  67.                   (and passwd (efs-code-string passwd))))
  68.  
  69. (defun efs-set-account (host user minidisk account)
  70.   "Given HOST, USER, and MINIDISK, set or change the ACCOUNT password.
  71. The minidisk is only relevant for CMS. If minidisk is irrelevant,
  72. give the null string for it. In lisp programs, give the minidisk as nil."
  73.   (interactive (efs-save-match-data
  74.          (let* ((path (or buffer-file-name
  75.                   (and (eq major-mode 'dired-mode)
  76.                        dired-directory)))
  77.             (parsed (and path (efs-ftp-path path)))
  78.             (default-host (car parsed))
  79.             (default-user (nth 1 parsed))
  80.             (default-minidisk
  81.               (and parsed
  82.                    (eq (efs-host-type default-host) 'cms)
  83.                    (string-match "^/[^/]+/" (nth 2 parsed))
  84.                    (substring (nth 2 parsed) 1
  85.                       (1- (match-end 0)))))
  86.             (host (read-string "Host: " default-host))
  87.             (user (read-string "User: " default-user))
  88.             (minidisk
  89.              (read-string
  90.               "Minidisk (enter null string if inapplicable): "
  91.               default-minidisk))
  92.             (account (read-passwd "Account password: ")))
  93.            (if (string-match "^ *$" minidisk)
  94.                (setq minidisk nil))
  95.            (list host user minidisk account))))
  96.   (and account (setq account (efs-code-string account)))
  97.   (if minidisk
  98.       (efs-put-hash-entry (concat (downcase host) "/" user "/" minidisk)
  99.               account efs-minidisk-hashtable)
  100.     (efs-set-host-user-property host user 'account account)))
  101.  
  102. ;;;; ------------------------------------------------------------
  103. ;;;; Parsing the ~/.netrc.
  104. ;;;; ------------------------------------------------------------
  105.  
  106. (defconst efs-netrc-modtime nil)
  107. ;; Last modified time of the netrc file from file-attributes.
  108.  
  109. (defun efs-netrc-next-token ()
  110.   ;; Gets the next token plus it's value.
  111.   ;; Returns \(token value-1 value-2 ...\)
  112.   (skip-chars-forward " \t\n")
  113.   (while (eq (char-after (point)) ?#)
  114.     (forward-line 1)
  115.     (skip-chars-forward " \t\n"))
  116.   (let ((tok (and (not (eobp))
  117.           (downcase (buffer-substring
  118.                  (point)
  119.                  (progn
  120.                    (skip-chars-forward "^ \n\t")
  121.                    (point)))))))
  122.     (cond
  123.      ((null tok) nil)
  124.      ((string-equal tok "default")
  125.       (list tok))
  126.      ((member tok (list "machine" "login" "password" "account"))
  127.       (list tok (efs-netrc-read-token-value)))
  128.      ((string-equal tok "minidisk")
  129.       (list tok (efs-netrc-read-token-value)
  130.         (efs-netrc-read-token-value)))
  131.      ((string-equal tok "include")
  132.       (let ((start (- (point) 7))
  133.         (path (expand-file-name (efs-netrc-read-token-value))))
  134.     (delete-region start (point))
  135.     (save-excursion (insert (efs-netrc-get-include path))))
  136.       (efs-netrc-next-token))
  137.      ;; Deal with tokens that we skip
  138.      ((string-equal tok "macdef")
  139.       (efs-save-match-data
  140.     (search-forward "\n\n" nil 'move))
  141.       (if (eobp)
  142.       nil
  143.     (efs-netrc-next-token)))
  144.      (t (error "efs netrc file error: Invalid token %s." tok)))))
  145.  
  146. (defun efs-netrc-read-token-value ()
  147.   ;; Read the following word as a token value.
  148.   (skip-chars-forward " \t\n")
  149.   (while (eq (char-after (point)) ?#)
  150.     (forward-line 1)
  151.     (skip-chars-forward " \t\n"))
  152.   (if (eq (following-char) ?\")    ;quoted token value
  153.       (prog2
  154.        (forward-char 1)
  155.        (buffer-substring (point)
  156.              (progn (skip-chars-forward "^\"") (point)))
  157.        (forward-char 1))
  158.     (buffer-substring (point)
  159.               (progn (skip-chars-forward "^ \n\t") (point)))))
  160.  
  161. (defun efs-netrc-get-include (path)
  162.   ;; Returns the text of an include file.
  163.   (let ((buff (create-file-buffer path)))
  164.     (unwind-protect
  165.     (save-excursion
  166.       (set-buffer buff)
  167.       (setq buffer-file-name path
  168.         default-directory (file-name-directory path))
  169.       (insert-file-contents path)
  170.       (normal-mode t)
  171.       (mapcar 'funcall find-file-hooks)
  172.       (setq buffer-file-name nil)
  173.       (buffer-string))
  174.       (condition-case nil
  175.       ;; go through this rigamoroll, because who knows
  176.       ;; where an interrupt in find-file-hooks leaves us.
  177.       (save-excursion
  178.         (set-buffer buff)
  179.         (set-buffer-modified-p nil)
  180.         (passwd-kill-buffer buff))
  181.     (error nil)))))
  182.  
  183. (defun efs-parse-netrc-group (&optional machine)
  184.   ;; Extract the values for the tokens  "machine", "login", "password",
  185.   ;; "account" and "minidisk"  in the current buffer.  If successful, 
  186.   ;; record the information found.
  187.   (let (data login)
  188.     ;; Get a machine token.
  189.     (if (or machine (setq data (efs-netrc-next-token)))
  190.     (progn
  191.       (cond
  192.        (machine) ; noop
  193.        ((string-equal (car data) "machine")
  194.         (setq machine (nth 1 data)))
  195.        ((string-equal (car data) "default")
  196.         (setq machine 'default))
  197.        (error
  198.         "efs netrc file error: %s"
  199.         "Token group must start with machine or default."))
  200.       ;; Next look for a login token.
  201.       (setq data (efs-netrc-next-token))
  202.       (cond
  203.        ((null data)
  204.         ;; This just interns in the hashtable for completion to
  205.         ;; work.  The username gets set later by efs-get-user.
  206.         (if (stringp machine) (efs-set-user machine nil))
  207.         nil)
  208.        ((string-equal (car data) "machine")
  209.         (if (stringp machine) (efs-set-user machine nil))
  210.         (nth 1 data))
  211.        ((string-equal (car data) "default")
  212.         'default)
  213.        ((not (string-equal (car data) "login"))
  214.         (error "efs netrc file error: Expected login token for %s."
  215.            (if (eq machine 'default)
  216.                "default"
  217.              (format "machine %s" machine))))
  218.        (t
  219.         (setq login (nth 1 data))
  220.         (if (eq machine 'default)
  221.         (setq efs-default-user login)
  222.           (efs-set-user machine login)
  223.           ;; Since an explicit login entry is given, intern an entry
  224.           ;; in the efs-host-user-hashtable for completion purposes.
  225.           (efs-set-host-user-property machine login nil nil))
  226.         (while (and (setq data (efs-netrc-next-token))
  227.             (not (or (string-equal (car data) "machine")
  228.                  (string-equal (car data) "default"))))
  229.           (cond
  230.            ((string-equal (car data) "password")
  231.         (if (eq machine 'default)
  232.             (setq efs-default-password (nth 1 data))
  233.           (efs-set-passwd machine login (nth 1 data))))
  234.            ((string-equal (car data) "account")
  235.         (if (eq machine 'default)
  236.             (setq efs-default-account (nth 1 data))
  237.           (efs-set-account machine login nil (nth 1 data))))
  238.            ((string-equal (car data) "minidisk")
  239.         (if (eq machine 'default)
  240.             (error "efs netrc file error: %s."
  241.                "Minidisk token is not allowed for default entry.")
  242.           (apply 'efs-set-account machine login (cdr data))))
  243.            ((string-equal (car data) "login")
  244.         (error "efs netrc file error: Second login token for %s."
  245.                (if (eq machine 'default)
  246.                "default"
  247.              (format "machine %s" machine))))))
  248.         (and data (if (string-equal (car data) "machine")
  249.               (nth 1 data)
  250.             'default))))))))
  251.  
  252. (defun efs-parse-netrc ()
  253.   "Parse the users ~/.netrc file, or file specified `by efs-netrc-filename'.
  254. If the file exists and has the correct permissions then extract the
  255. \`machine\', \`login\', \`password\', \`account\', and \`minidisk\'
  256. information from within."
  257.   (interactive)
  258.   (and efs-netrc-filename
  259.        (let* ((file (expand-file-name efs-netrc-filename))
  260.           ;; Set to nil to avoid an infinite recursion if the
  261.           ;; .netrc file is remote.
  262.           (efs-netrc-filename nil)
  263.           (file (efs-chase-symlinks file))
  264.           (attr (file-attributes file))
  265.           netrc-buffer next)
  266.      (if (or (interactive-p) ; If interactive, really do something.
  267.          (and attr     ; file exists.
  268.               ;; file changed
  269.               (not (equal (nth 5 attr) efs-netrc-modtime))))
  270.          (efs-save-match-data
  271.            (or efs-disable-netrc-security-check
  272.            (and (eq (nth 2 attr) (user-uid)) ; Same uids.
  273.             (string-match ".r..------" (nth 8 attr)))
  274.            (efs-netrc-scream-and-yell file attr))
  275.            (unwind-protect
  276.            (save-excursion
  277.              ;; we are cheating a bit here.  I'm trying to do the
  278.              ;; equivalent of find-file on the .netrc file, but
  279.              ;; then nuke it afterwards.
  280.              ;; with the bit of logic below we should be able to have
  281.              ;; encrypted .netrc files.
  282.              (set-buffer (setq netrc-buffer
  283.                        (generate-new-buffer "*ftp-.netrc*")))
  284.              (insert-file-contents file)
  285.              (setq buffer-file-name file)
  286.              (setq default-directory (file-name-directory file))
  287.              (normal-mode t)
  288.              (mapcar 'funcall find-file-hooks)
  289.              (setq buffer-file-name nil)
  290.              (goto-char (point-min))
  291.              (while (and (not (eobp))
  292.                  (setq next (efs-parse-netrc-group next)))))
  293.          (condition-case nil
  294.              ;; go through this rigamoroll, because we knows
  295.              ;; where an interrupt in find-file-hooks leaves us.
  296.              (save-excursion
  297.                (set-buffer netrc-buffer)
  298.                (set-buffer-modified-p nil)
  299.                (passwd-kill-buffer netrc-buffer))
  300.            (error nil)))
  301.            (setq efs-netrc-modtime (nth 5 attr)))))))
  302.  
  303. (defun efs-netrc-scream-and-yell (file attr)
  304.   ;; Complain about badly protected netrc files.
  305.   (let* ((bad-own (/= (nth 2 attr) (user-uid)))
  306.      (modes (nth 8 attr))
  307.      (bad-protect (not (string-match ".r..------" modes))))
  308.     (if (or bad-own bad-protect)
  309.     (save-window-excursion
  310.       (with-output-to-temp-buffer "*Help*"
  311.         (if bad-own
  312.         (princ
  313.          (format
  314.           "Beware that your .netrc file %s is not owned by you.\n"
  315.           file)))
  316.         (if bad-protect
  317.         (progn
  318.           (if bad-own
  319.               (princ "\nAlso,")
  320.             (princ "Beware that"))
  321.           (princ
  322.            " your .netrc file ")
  323.           (or bad-own (princ (concat file " ")))
  324.           (princ
  325.            (format
  326.             "has permissions\n %s.\n" modes))))
  327.         (princ
  328.          "\nIf this is intentional, then setting \
  329. efs-disable-netrc-security-check
  330. to t will inhibit this warning in the future.\n"))
  331.       (select-window (get-buffer-window "*Help*"))
  332.       (enlarge-window (- (count-lines (point-min) (point-max))
  333.                  (window-height) -1))
  334.       (if (and bad-protect
  335.            (y-or-n-p (format "Set permissions on %s to 600? " file)))
  336.           (set-file-modes file 384))))))
  337.  
  338. ;;;; ----------------------------------------------------------------
  339. ;;;; Completion in the root directory.
  340. ;;;; ----------------------------------------------------------------
  341.  
  342. (defun efs-generate-root-prefixes ()
  343.   "Return a list of prefixes of the form \"user@host:\".
  344. Used when completion is done in the root directory."
  345.   (efs-parse-netrc)
  346.   (efs-save-match-data
  347.     (let (res)
  348.       (efs-map-hashtable
  349.        (function
  350.     (lambda (key value)
  351.       (if (string-match "^[^/]+\\(/\\).+$" key)
  352.           ;; efs-passwd-hashtable may have entries of the type
  353.           ;; "machine/" to indicate a password assigned to the default
  354.           ;; user for "machine". Don't use these entries for completion.
  355.           (let ((host (substring key 0 (match-beginning 1)))
  356.             (user (substring key (match-end 1))))
  357.         (setq res (cons (list (format
  358.                        efs-path-user-at-host-format
  359.                        user host))
  360.                 res))))))
  361.        efs-host-user-hashtable)
  362.       (efs-map-hashtable
  363.        (function (lambda (host user)
  364.            (setq res (cons (list (format efs-path-host-format
  365.                          host))
  366.                    res))))
  367.        efs-host-hashtable)
  368.       (if (and (null res)
  369.            (string-match "^1[0-8]\\.\\|^[0-9]\\." emacs-version))
  370.       (list nil)
  371.     res))))
  372.  
  373. ;;;###autoload
  374. (defun efs-root-file-name-all-completions (file dir)
  375.   ;; Generates all completions in the root directory.
  376.   (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn
  377.                   'efs-root-handler-function)))
  378.     (nconc (all-completions file (efs-generate-root-prefixes))
  379.        (file-name-all-completions file dir))))
  380.  
  381.  
  382. ;;;###autoload
  383. (defun efs-root-file-name-completion (file dir)
  384.   ;; Calculates completions in the root directory to include remote hosts.
  385.   (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn
  386.                   'efs-root-handler-function)))
  387.     (try-completion
  388.      file
  389.      (nconc (efs-generate-root-prefixes)
  390.         (mapcar 'list (file-name-all-completions file "/"))))))
  391.  
  392.  
  393. ;;; end of efs-netrc.el
  394.